Proyecto 2 (personal)

1 Situación Problemática

No se ha buscado la relacion entre habilidades cognitivas, crecimiento y salud de los huesos utilizando los datos del estudio longitudinal de la UVG y los estudios que se han realizado con datos parecidos no han sido bien investigados en paises de bajos y medianos ingresos.

Los datos utilizados para este analisis son el producto de un estudio longitudinal diseñado por el Dr. Barry Bogin hace mas de 50 años en conjunto con el Colegio Americano de Guatemala. Ellos se propusieron a colectar datos longitudinalmente de estudiantes de todos los años y darle seguimiento a su crecimiento de forma anual hasta el momento en el que completaban sus estudios de bachillerato. El estudio se expandió a 6 colegios más a lo largo de los años y se cuenta con datos de peso, talla, IQ, pruebas de lectura y masa osea para registros comenzando en el año 1953.

Esta base de datos pertenece a la fundación Bill and Melinda Gates, los cuales donaron los fondos necesarios para digitalizarla.

2 Problema Cientifico

2.1 Objetivos

3 Conjunto de datos

3.1 Leyendo Datos

• Subjects: Informacion personal de cada sujeto de prueba.
• Card1: Informacion fisiológica de los sujetos.
• Card2: Informacion fisiológica complementaria.

subjects = as.data.table(read_xlsx("./data/1-Subjects sex_ID_school_DOB.xlsx"))
card1 = as.data.table(read_xlsx("./data/4-Card1.xlsx"))
card2 = as.data.table(read_xlsx("./data/5-Card2.xlsx"))

3.1.1 Variables desechadas

En las tres bases de datos existen registros de control de digitalizacion como.

• entering date: Fecha en la que los datos fueron digitalizados.
• User : Usuario que digitalizó el dato.

Estas variables, por ser solo de control, junto a Repetition en Card1 y Card2, que no esta presente en casi todo el conjunto de datos, seran desechadas.

3.1.2 Subject

En Subjects podemos encontrar las siguientes variables personales de cada sujeto de estudio.

• ID: Identificador personal para cada persona involucrada en el set de datos.
• DOB: Fecha de nacimiento de la persona.
• DOB decimal: Año de nacimiento de la persona en representacion decimal.
• Sex: Sexo de la persona.
• IdSchool 1: Identificador del colegio al que asistió la persona.
• IdSchool 2: Valor booleano que representa si el sujeto ya no estudia en el colegio representado en IdSchool 1

3.1.3 Card1

En Card1 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.

• yearCard1: Año en el que se recopilaron los datos.
• gradeCard1: Grado escolar al que pertenecía la persona.
• Height: Altura de la persona en centimetros.
• Weight: Peso de la persona en kg.
• Hand grip: Fuerza de la mano calculado en kg.
• Dental: Dentición piezas del sujeto. Número de piezas permanentes eruptadas.

3.1.4 Card2

En Card2 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.

• yearCard2: Año en el que se recopilaron los datos.
• grade Card 2: Grado escolar al que pertenecía la persona.
• UAC1: Circunferencia Tricep 1
• UAC2: Circunferencia Tricep 2
• TST1: Pliegue Cutáneo Tricep 1
• TST2: Pliegue Cutáneo Tricep 2
• SSF1: Pliegue Cutáneo Subescapular 1
• SSF2: Pliegue Cutáneo Subescapular 2

3.2 Union y Limpieza de Datos

Uniremos cada conjunto de datos con la informacion respectiva de cada sujeto de observacion. Para eso las uniremos basandonos en el ID. Crearemos 3 nuevas tablas. La primer tabla contendra a los sujetos (Subjects) y ambas tablas de caracteristicas fisiologicas (Card1 y Card2). Esta primer tabla se utilizara para explorar ambos Cards como uno solo. En contraste, se realizara una tabla para cada Card individualmente, con el proposito de poder realizar un analisis de clustering por separado y analizar como se comportan los Cards individualmente.

Subject es el conjunto de datos que uniremos con los datos recopilados en Card1 y Card2. La limpieza en este conjunto de datos sera tan simple como volver Factores las variables Sex, IdSchool 1 y el ID del sujeto de observacion. Por otro lado desecharemos IdSchool 2 que solo representa un valor booleano donde es TRUE si el estudiante cambio de colegio.

subSubject = subjects[,c(1:5)]
subSubject$Sex = as.factor(subSubject$Sex)
subSubject$`IdSchool 1` = as.factor(subSubject$`IdSchool 1`)
subSubject$ID = as.factor(subSubject$ID)

3.2.1 Subject-Card1-Card2

mainData = subjects
c1 = card1
c2 = card2 

colnames(mainData)[1] <- "Id"
colnames(c1)[2] <- "date" 
colnames(c2)[2] <- "date"

cards <- merge(c1, c2, by = c("Id", "date"))
completeData <- merge(mainData, cards, by = "Id")
completeData$age <- round(completeData$date - completeData$`DOB decimal`, 0)

3.2.2 Subject-Card1

Uniremos Card1 con Subject por medio del ID. Para poder combinar ambos conjuntos de datos realizaremos lo siguiente en Card1:

• Desecharemos las variables entering date, User, RepetitionCard1.
• Renombraremos Id como ID.
• Convertir a factor ID.
• Convertir a factor gradeCard1.
• Por ultimo combinamos ambos conjuntos de datos.

subCard1 = card1[,c(1:7)]
names(subCard1)[1] = "ID"
subCard1$ID = as.factor(subCard1$ID)
subCard1$gradeCard1 = as.factor(subCard1$gradeCard1)

Card1 = merge(subSubject,subCard1)
Card1 = na.omit(Card1)

Card1$`Hand grip` = as.numeric(Card1$`Hand grip`)
Card1$edad = round(Card1$yearCard1-Card1$`DOB decimal`,0)

3.2.3 Subject-Card2

Uniremos Card2 con Subject por medio del ID. Para poder combinar ambos conjuntos de datos realizaremos lo siguiente en Card2:

• Desecharemos las variables entering date, User, Repetition.
• Renombraremos Id como ID.
• Convertir a factor ID.
• Convertir a factor gradeCard2.
• Por ultimo combinamos ambos conjuntos de datos.

4 Analisis Exploratorio

4.1 Card1-Card2

4.1.1 Exploración de variables y eliminacion de outlier

4.1.1.1 Frecuencia de edades

ggplot(completeData, aes(x = age)) +
  geom_bar() +
  labs(x = "Edad", y = "Frecuencia")

4.1.1.2 Altura por Edad

ggplot(completeData, aes(group = age, x = age, y = Height)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Altura (cm)")

Las alturas de más de 250 cm no tienen sentido. Además, las edades mayores a 22 años tienen muy pocos datos. Se decidió removerlos:

completeData <- completeData %>% 
  filter(Height < 250) %>% 
  filter(age < 23)

4.1.1.2.1 Sin outliers

4.1.1.3 Pesos por Edades

Pesos mayores a 200 kg no tienen sentidos. Se decidió eliminarlos:

completeData <- completeData %>% 
  filter(Weight < 200)

4.1.1.3.1 Sin outliers

ggplot(completeData, aes(group = age, x = age, y = Weight)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Peso (kg)")

4.1.1.4 Regresion Lineal Peso-Altura

Solo existen 4 datos para mediciones con cuatro años de edad. Se eliminarán:

completeData <- completeData %>% 
  filter(age > 4)

4.1.1.5 Altura-Dientes

No tiene sentido que hayan niños tan altos sin dientes permanentes “erupcionados”. Según la Asociación Dental de América, se espera que a partir de los 6-7 años por lo menos se hayan desarrollado los incisivos centrales. Probablemente esos “0”s signifiquen que no fue registrado el dato. Para comprobar cuántos registros de niños mayores años no tienen dientes permanentes “erupcionados”:

paste(round((nrow(filter(completeData, age > 7 & Dental == 0)) 
             / nrow(completeData) * 100),2), "%")

## [1] "62.46 %"

Más del 60% de los datos no tienen ese registro, por lo que no se utilizará esta columna.

completeData <- completeData %>% 
  mutate(Dental = NULL)

4.1.1.6 IdSchool | Repetition | RepetitionCard1

IdSchool2, que indica si se cambiaron de colegio parece tener muchos NAs. Chequear:

paste(round(nrow(filter(completeData, is.na(`IdSchool 2`))) / 
              nrow(completeData) * 100, 2), "%")

## [1] "99.86 %"

Casi el 100% de los registros no poseen esta información. Se eliminará esta columna. Además, se eliminarán las columnas Repetition y RepetitionCard1 ya que estas proveen poca información acerca de la altura. Es más, los alumnos repitentes podrían distorsionar las predicciones.

colnames(completeData)[6] <- "IdSchool2"

completeData <- completeData %>% 
  mutate(IdSchool2 = NULL) %>% 
  mutate(Repetition = NULL) %>% 
  mutate(RepetitionCard1 = NULL)

4.1.1.7 Fuerza de Agarre (Hand grip)

Visualizar los datos de pruebas de fuerza de agarre:

No existen registros de pruebas de fuerza de agarre en los que se superen los 100 kg de fuerza de agarre, por lo que se eliminarán los outliers y se vuelve a graficar:

4.1.1.7.1 Sin outliers

4.1.1.8 Fuerza de Agarre-Edad

La fuerza de agarre presenta una distribución aparentemente normal desde los 5 hasta los 14 años. Sin embargo, a partir de los 15 años y sobre todo entre los 17 y 19 años, se pueden observar claramente dos distribuciones que se traslapan. Esto indica que en estas edades la diferencia de fuerza de agarre es mucho más marcada. Se tendrá esto en cuenta para futuras predicciones.

4.1.2 Desecho de Variables

Se eliminarán otras variables poco útiles como entering date, entering data y User. También se eliminarán DOB y DOB decimal debido a que ya se calculó la edad en cada registro.

completeData <- completeData %>% 
  mutate(`entering date` = NULL) %>% 
  mutate(`entering data` = NULL) %>% 
  mutate(User.x = NULL) %>% 
  mutate(User.y = NULL) %>% 
  mutate(DOB = NULL) %>% 
  mutate(`DOB decimal` = NULL)

4.1.3 Analisís de Componentes Principales

Se evalurá la factibilidad de realizar un análisis de componentes principales utilizando la base de datos unificada del estudio.

pafDatos<-paf(as.matrix(completeData[,5:16]))
pafDatos$KMO

## [1] 0.85819

pafDatos$Bartlett

## [1] 2421661

summary(pafDatos)

## $KMO
## [1] 0.85819
## 
## $MSA
##                  MSA
## gradeCard1   0.83601
## Height       0.92163
## Weight       0.90310
## Hand grip    0.93607
## grade Card 2 0.83729
## UAC1 cm      0.80366
## UAC2 cm      0.80384
## TST1 mm      0.79714
## TST2 mm      0.79821
## SSF1 mm      0.82860
## SSF2 mm      0.82802
## age          0.97772
## 
## $Bartlett
## [1] 2421661
## 
## $Communalities
##              Initial Communalities Final Extraction
## gradeCard1                 0.98864          0.86969
## Height                     0.91941          0.89379
## Weight                     0.94778          0.91475
## Hand grip                  0.87239          0.81608
## grade Card 2               0.98821          0.86286
## UAC1 cm                    0.99593          0.57538
## UAC2 cm                    0.99593          0.57583
## TST1 mm                    0.95257          0.87040
## TST2 mm                    0.95345          0.87526
## SSF1 mm                    0.96472          0.85979
## SSF2 mm                    0.96527          0.86265
## age                        0.87765          0.87558
## 
## $Factor.Loadings
##                 [,1]      [,2]
## gradeCard1   0.83186  0.421540
## Height       0.86610  0.379030
## Weight       0.94769  0.128999
## Hand grip    0.79661  0.426023
## grade Card 2 0.82895  0.419168
## UAC1 cm      0.75196 -0.099723
## UAC2 cm      0.75240 -0.098627
## TST1 mm      0.62367 -0.693855
## TST2 mm      0.62832 -0.693163
## SSF1 mm      0.74177 -0.556386
## SSF2 mm      0.74497 -0.554685
## age          0.83275  0.426734
## 
## $RMS
## [1] 0.06673

cortest.bartlett(completeData[,5:16])

## R was not square, finding R from data

## $chisq
## [1] 2421661
## 
## $p.value
## [1] 0
## 
## $df
## [1] 66

Como se puede observar se obtuvo un KMO de 0.86 y un coeficiente de Bartlett muy elevado 2421661 por lo que parece que un analisis de componentes principales es una buena idea. Considerando que el valor P indicado es de 0.

4.1.3.1 Matriz de Correlación

kable(cor(completeData[,5:16],use = "pairwise.complete.obs"))

	gradeCard1	Height	Weight	Hand grip	grade Card 2	UAC1 cm	UAC2 cm	TST1 mm	TST2 mm	SSF1 mm	SSF2 mm	age
gradeCard1	1.00000	0.85642	0.80228	0.79474	0.99407	0.52634	0.52730	0.25657	0.26091	0.38685	0.39029	0.91085
Height	0.85642	1.00000	0.91494	0.89282	0.85281	0.58129	0.58226	0.29185	0.29662	0.42381	0.42747	0.88912
Weight	0.80228	0.91494	1.00000	0.87762	0.79881	0.67960	0.68011	0.49158	0.49587	0.65187	0.65517	0.82837
Hand grip	0.79474	0.89282	0.87762	1.00000	0.79096	0.56453	0.56529	0.17854	0.18261	0.36030	0.36338	0.82867
grade Card 2	0.99407	0.85281	0.79881	0.79096	1.00000	0.52448	0.52544	0.25642	0.26075	0.38604	0.38954	0.90770
UAC1 cm	0.52634	0.58129	0.67960	0.56453	0.52448	1.00000	0.99796	0.49494	0.49773	0.55659	0.55872	0.53124
UAC2 cm	0.52730	0.58226	0.68011	0.56529	0.52544	0.99796	1.00000	0.49426	0.49723	0.55613	0.55844	0.53227
TST1 mm	0.25657	0.29185	0.49158	0.17854	0.25642	0.49494	0.49426	1.00000	0.97528	0.81731	0.81670	0.23896
TST2 mm	0.26091	0.29662	0.49587	0.18261	0.26075	0.49773	0.49723	0.97528	1.00000	0.81942	0.82167	0.24326
SSF1 mm	0.38685	0.42381	0.65187	0.36030	0.38604	0.55659	0.55613	0.81731	0.81942	1.00000	0.98156	0.39265
SSF2 mm	0.39029	0.42747	0.65517	0.36338	0.38954	0.55872	0.55844	0.81670	0.82167	0.98156	1.00000	0.39621
age	0.91085	0.88912	0.82837	0.82867	0.90770	0.53124	0.53227	0.23896	0.24326	0.39265	0.39621	1.00000

En la matriz de correlación observamos que algunas variables se encuentran relacionadas por lo que se procederá a realizar el analisis de componentes principales para intentar reducir el dataset.

compPrinc<-prcomp(completeData[,5:16], scale = T)
compPrinc

## Standard deviations (1, .., p=12):
##  [1] 2.747880 1.616276 0.945767 0.616485 0.530066 0.331774 0.289067
##  [8] 0.191409 0.158106 0.134579 0.076765 0.045137
## 
## Rotation (n x k) = (12 x 12):
##                   PC1       PC2         PC3       PC4       PC5        PC6
## gradeCard1   -0.30402 -0.269728 -0.17419177  0.386389 -0.234360  0.2861933
## Height       -0.31566 -0.240491 -0.08544647 -0.166156  0.327941 -0.3019616
## Weight       -0.34461 -0.082912 -0.06780173 -0.325511  0.198839  0.0312608
## Hand grip    -0.29345 -0.277905  0.00034632 -0.438209  0.308244  0.4483749
## grade Card 2 -0.30323 -0.268916 -0.17535250  0.394547 -0.241602  0.3021934
## UAC1 cm      -0.28731  0.071474  0.63307756  0.081034 -0.067685 -0.0190826
## UAC2 cm      -0.28746  0.070688  0.63273700  0.081282 -0.067764 -0.0203844
## TST1 mm      -0.22837  0.437769 -0.14810593  0.290329  0.381329  0.0292302
## TST2 mm      -0.22992  0.436513 -0.14859961  0.285664  0.373207  0.0262647
## SSF1 mm      -0.27187  0.351788 -0.17273338 -0.296650 -0.416498 -0.0087179
## SSF2 mm      -0.27294  0.350316 -0.17240415 -0.294025 -0.412101 -0.0110911
## age          -0.30416 -0.272437 -0.14929806  0.126191 -0.086260 -0.7287328
##                     PC7         PC8         PC9       PC10        PC11
## gradeCard1    0.0918366  3.7745e-03 -0.00113199  0.0021659  7.1407e-01
## Height        0.6014369 -4.9689e-01 -0.01484548 -0.0059592 -2.2446e-03
## Weight        0.2623324  8.0877e-01  0.01339201  0.0131188 -3.7436e-03
## Hand grip    -0.5351493 -2.4934e-01  0.00010077 -0.0041179 -1.0911e-03
## grade Card 2  0.0982152 -1.2631e-05 -0.00049849 -0.0021059 -6.9998e-01
## UAC1 cm       0.0050754 -1.2907e-02 -0.00370159  0.0029173 -1.7807e-04
## UAC2 cm       0.0059720 -1.4720e-02  0.00257875 -0.0029193  2.0569e-04
## TST1 mm      -0.0957052  1.9579e-03 -0.68737781 -0.1485137  2.3840e-06
## TST2 mm      -0.0847347 -2.9944e-02  0.69407875  0.1520099 -1.7301e-04
## SSF1 mm       0.0145549 -1.2420e-01 -0.15578984  0.6863127 -1.2298e-03
## SSF2 mm       0.0175293 -1.0822e-01  0.14513340 -0.6953813  3.0119e-03
## age          -0.4980667  9.1534e-02  0.00326062  0.0023756 -9.7776e-03
##                     PC12
## gradeCard1   -2.7453e-04
## Height       -1.3946e-03
## Weight        8.6385e-04
## Hand grip     3.2365e-04
## grade Card 2  9.3014e-05
## UAC1 cm      -7.0699e-01
## UAC2 cm       7.0720e-01
## TST1 mm       2.6839e-03
## TST2 mm      -2.2620e-03
## SSF1 mm       3.5020e-03
## SSF2 mm      -3.5226e-03
## age          -4.8634e-04

summary(compPrinc)

## Importance of components:
##                          PC1   PC2    PC3    PC4    PC5     PC6     PC7
## Standard deviation     2.748 1.616 0.9458 0.6165 0.5301 0.33177 0.28907
## Proportion of Variance 0.629 0.218 0.0745 0.0317 0.0234 0.00917 0.00696
## Cumulative Proportion  0.629 0.847 0.9215 0.9531 0.9766 0.98573 0.99269
##                            PC8     PC9    PC10    PC11    PC12
## Standard deviation     0.19141 0.15811 0.13458 0.07677 0.04514
## Proportion of Variance 0.00305 0.00208 0.00151 0.00049 0.00017
## Cumulative Proportion  0.99575 0.99783 0.99934 0.99983 1.00000

compPrincPCA<-PCA(completeData[,5:16],ncp=ncol(completeData[,5:16]), scale.unit = T)

4.2 Card1

4.2.1 Descripcion de Variables

En Card1 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.

• ID: Identificador personal para cada persona involucrada en el set de datos.
• DOB: Fecha de nacimiento de la persona.
• DOB decimal: Año de nacimiento de la persona en representacion decimal.
• Sex: Sexo de la persona.
• IdScholl 1: Identificador del colegio al que asistió la persona.
• yearCard1: Año en el que se recopilaron los datos.
• gradeCard1: Grado escolar al que pertenecía la persona.
• Height: Altura de la persona en centimetros.
• Weight: Peso de la persona en kg.
• Hand grip: Fuerza de la mano calculado en kg.
• Dental: Dentición piezas del sujeto. Número de piezas permanentes eruptadas.
• Edad: Edad del sujeto.

4.2.2 Resumen de Variables

head(Card1)

##       ID        DOB DOB decimal Sex IdSchool 1 yearCard1 gradeCard1 Height
## 1: 10001 1947-11-27        47.9   M          1     53.17          1    113
## 2: 10001 1947-11-27        47.9   M          1     54.18          2    116
## 3: 10001 1947-11-27        47.9   M          1     55.18         11    121
## 4: 10001 1947-11-27        47.9   M          1     56.18         11    125
## 5: 10001 1947-11-27        47.9   M          1     57.17         12    131
## 6: 10001 1947-11-27        47.9   M          1     58.17         13    136
##    Weight Hand grip Dental edad
## 1:   21.8       287      0    5
## 2:   22.2         1      0    6
## 3:   24.5         7      0    7
## 4:   27.2         8      0    8
## 5:   29.0        14      0    9
## 6:   32.2        12      0   10

summary(Card1)

##        ID              DOB                       DOB decimal   Sex      
##  10162  :    14   Min.   :1939-05-20 00:00:00   Min.   :39.4   F:67752  
##  10226  :    14   1st Qu.:1961-07-15 06:00:00   1st Qu.:61.5   M:89394  
##  10243  :    14   Median :1969-09-29 12:00:00   Median :69.7            
##  10275  :    14   Mean   :1970-01-01 15:18:53   Mean   :70.0            
##  10281  :    14   3rd Qu.:1978-03-02 00:00:00   3rd Qu.:78.2            
##  10313  :    14   Max.   :1994-04-16 00:00:00   Max.   :94.3            
##  (Other):157062                                                         
##  IdSchool 1   yearCard1      gradeCard1        Height        Weight     
##  1:42283    Min.   :53.2   11     :27094   Min.   : 93   Min.   : 11.4  
##  2:28136    1st Qu.:73.2   12     :23931   1st Qu.:124   1st Qu.: 25.0  
##  3:23492    Median :81.2   14     :21946   Median :138   Median : 33.6  
##  4: 6709    Mean   :81.2   16     :19473   Mean   :139   Mean   : 37.4  
##  5:41196    3rd Qu.:90.1   21     :15264   3rd Qu.:154   3rd Qu.: 47.7  
##  6: 2418    Max.   :99.3   23     :12101   Max.   :287   Max.   :287.0  
##  7:12912                   (Other):37337                                
##    Hand grip         Dental            edad     
##  Min.   :  0.0   Min.   :  0.00   Min.   : 4.0  
##  1st Qu.: 11.0   1st Qu.:  0.00   1st Qu.: 8.0  
##  Median : 16.0   Median :  0.00   Median :11.0  
##  Mean   : 19.4   Mean   :  4.91   Mean   :11.2  
##  3rd Qu.: 24.0   3rd Qu.:  8.00   3rd Qu.:13.0  
##  Max.   :287.0   Max.   :287.00   Max.   :33.0  
## 

4.2.3 Cruce de Variables

Veamos que variables tienen relacion entre si con ayuda de las correlacion representadas con heatmaps.

datos = Card1[,c(3:12)]
datos$Sex = as.factor(datos$Sex)
datos$Sex = as.numeric(datos$Sex)
datos$`IdSchool 1` = as.numeric(datos$`IdSchool 1`)
datos$gradeCard1 = as.numeric(datos$gradeCard1)

#Obtener matriz de correlacion
cormat = round(cor(datos,use = "complete.obs"),2)
#Reordenar matriz de correlacion
reorder_cormat <- function(cormat){
# Use correlation between variables as distance
dd <- as.dist((1-cormat)/2)
hc <- hclust(dd)
cormat <-cormat[hc$order, hc$order]
}
cormat = reorder_cormat(cormat)
#Obtener triangulo superior
get_upper_tri = function(cormat){
  cormat[lower.tri(cormat)] = NA
  return(cormat)
}
upper_tri = get_upper_tri(cormat)
#Correlacion como heatmap
require(reshape2)

## Loading required package: reshape2

## 
## Attaching package: 'reshape2'

## The following objects are masked from 'package:data.table':
## 
##     dcast, melt

melted_cormat = melt(upper_tri, na.rm = T)
require(ggplot2)
ggheatmap = ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill = value)) + geom_tile(color = "white") + scale_fill_gradient2(low = "blue",high = "red",mid = "white", midpoint = 0, limit = c(-1,1), space = "Lab", name="Correlacion") + theme_minimal() + theme(axis.text.x = element_text(angle = 90, vjust = 1,hjust = 1)) + coord_fixed()

ggheatmap + 
geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
theme(
  axis.title.x = element_blank(),
  axis.title.y = element_blank(),
  panel.grid.major = element_blank(),
  panel.border = element_blank(),
  panel.background = element_blank(),
  axis.ticks = element_blank(),
  legend.justification = c(1, 0),
  legend.position = c(0.6, 0.7),
  legend.direction = "horizontal")+
  guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
                title.position = "top", title.hjust = 0.5))

Gracias al heatmap de correlaciones. Podemos ver que la mayoria de variables tiene una alta correlacion con la edad. Esto significa que las demas variables dependen mucho de la edad. La cual es obvio ya que hablamos de caracteristicas fisiológicas.

4.2.4 Graficos Exploratorios

4.2.5 Cluster

Como tecnica de exploración, permitiremos que la máquina corra algoritmos de agrupamiento no supervisados para poder analizar los patrones que la máquina encontró. De primero corramos un diagrama de codo del metodo de Ward para definir la cantidad de grupos a realizar.

library(factoextra)

## Welcome! Related Books: `Practical Guide To Cluster Analysis in R` at https://goo.gl/13EFCZ

cluster = Card1[complete.cases(Card1),c(3,4,5,7:12)]
cluster = unique(cluster)
cluster$Sex = as.factor(cluster$Sex)
cluster$Sex = as.numeric(cluster$Sex)
cluster$`IdSchool 1` = as.numeric(cluster$`IdSchool 1`)
cluster$gradeCard1 = as.numeric(cluster$gradeCard1)

set.seed(12)

cluster[is.na(cluster)] = 0
wss <- (nrow(cluster[,c()])-1)*sum(apply(cluster[,1:ncol(cluster)],2,var))

for (i in 2:10) 
  wss[i] <- sum(kmeans(cluster[,1:ncol(cluster)], centers=i)$withinss)

## Warning: Quick-TRANSfer stage steps exceeded maximum (= 7856250)

plot(2:
       10, wss[c(2:10)], type="b", xlab="Number of Cluster",  ylab="Squares Summatory", main = "Diagrama de Codo")

Gracias al diagrama de codo, se considera 5 como la cantidad optima de grupos a realizar. Para realizar el clusterin utilizaremos la tecnica de K-medias.

require("fpc")

## Loading required package: fpc

set.seed(90)
km = kmeans(cluster, 5)
cluster$grupo<-km$cluster

plotcluster(cluster[,c(1:9)],cluster$grupo)

Ahora que ya tenemos los clusters realizados, analicemos como los datos fueron agrupados. Debido a que las variables son cuantitativas y por temas de percepcio, utilizaremos los boxplots para identificar como difieren las distintas variables entre grupos.

ggplot(data = cluster, aes(group = grupo, y = edad, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Edad") + ylim(c(0,25))

## Warning: Removed 3 rows containing non-finite values (stat_boxplot).

ggplot(data = cluster, aes(group = grupo, y = Height, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Altura (cm)") + ylim(c(100,200))

## Warning: Removed 89 rows containing non-finite values (stat_boxplot).

ggplot(data = cluster, aes(group = grupo, y = Weight, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Peso (kg)") + ylim(c(0,100))

## Warning: Removed 177 rows containing non-finite values (stat_boxplot).

ggplot(data = cluster, aes(group = grupo, y = `Hand grip`, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Hand grip") + ylim(c(0,70))

## Warning: Removed 370 rows containing non-finite values (stat_boxplot).

ggplot(data = cluster, aes(group = grupo, y = gradeCard1, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Grado Escolar")

En definitiva, los boxplots nos permiten ver como varian las variables dentro de los grupos. Conforme a las gráficas me atrevería a ordenar los grupos de forma ascendente de la siguiente manera.

1. Grupo 5
2. Grupo 3
3. Grupo 4
4. Grupo 2
5. Grupo 1

Ademas de que los graficos demuestran que las edades son una variable fuerte para decidir la pertenencia a un grupo, tambien demuestra la relacion que tiene con las demas variables. Las demas variables cambian proporcionalmente a la edad, lo que se puede reflejar en la matriz de correlaciones presentada anteriormente.

4.3 Card2

4.3.1 Descripcion de Variables

En Card2 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.

• ID: Identificador personal para cada persona involucrada en el set de datos.
• DOB: Fecha de nacimiento de la persona.
• DOB decimal: Año de nacimiento de la persona en representacion decimal.
• Sex: Sexo de la persona.
• IdScholl 1: Identificador del colegio al que asistió la persona.
• yearCard2: Año en el que se recopilaron los datos.
• grade Card 2: Grado escolar al que pertenecía la persona.
• UAC1: Circunferencia Tricep 1
• UAC2: Circunferencia Tricep 2
• TST1: Pliegue Cutáneo Tricep 1
• TST2: Pliegue Cutáneo Tricep 2
• SSF1: Pliegue Cutáneo Subescapular 1
• SSF2: Pliegue Cutáneo Subescapular 2
• Edad: Edad del sujeto.

4.3.2 Resumen de Variables

head(Card2)

##       ID        DOB DOB decimal Sex IdSchool 1 yearCard2 grade Card 2
## 1: 10605 1954-05-18       54.38   M          1     72.19           25
## 2: 10608 1954-01-09       54.02   F          1     72.19           25
## 3: 10647 1954-06-18       54.46   M          1     72.19           25
## 4: 10659 1953-11-18       53.87   F          1     72.19           25
## 5: 10704 1954-02-09       54.11   M          1     72.19           25
## 6: 10708 1954-09-11       54.69   M          1     72.20           24
##    UAC1 cm UAC2 cm TST1 mm TST2 mm SSF1 mm SSF2 mm edad
## 1:       0       0       8       8      11      11   18
## 2:       0       0      12      12      14      13   18
## 3:       0       0       8       8       9       9   18
## 4:       0       0      19      19      17      17   18
## 5:       0       0      17      15      18      17   18
## 6:       0       0       6       6       8       8   18

summary(Card2)

##        ID             DOB                       DOB decimal   Sex      
##  12571  :   13   Min.   :1950-03-17 00:00:00   Min.   :50.2   F:43222  
##  12599  :   13   1st Qu.:1970-04-24 00:00:00   1st Qu.:70.3   M:56655  
##  12624  :   13   Median :1975-08-21 00:00:00   Median :75.6            
##  12669  :   13   Mean   :1976-01-12 21:49:46   Mean   :76.0            
##  12704  :   13   3rd Qu.:1982-03-05 00:00:00   3rd Qu.:82.2            
##  12711  :   13   Max.   :1994-04-16 00:00:00   Max.   :94.3            
##  (Other):99799                                                         
##  IdSchool 1   yearCard2     grade Card 2      UAC1 cm        UAC2 cm    
##  1:28643    Min.   :71.2   11     :18375   Min.   : 0.0   Min.   : 0.0  
##  2:15925    1st Qu.:81.3   12     :16463   1st Qu.:18.0   1st Qu.:18.0  
##  3:14239    Median :87.1   14     :15802   Median :20.5   Median :20.5  
##  4: 2280    Mean   :87.2   16     :14226   Mean   :20.4   Mean   :20.4  
##  5:23519    3rd Qu.:93.2   21     :10713   3rd Qu.:24.0   3rd Qu.:24.0  
##  6: 2399    Max.   :99.3   23     : 8452   Max.   :43.0   Max.   :42.5  
##  7:12872                   (Other):15846                                
##     TST1 mm        TST2 mm        SSF1 mm        SSF2 mm    
##  Min.   : 2.0   Min.   : 2.0   Min.   : 0.0   Min.   : 0.0  
##  1st Qu.: 8.0   1st Qu.: 7.0   1st Qu.: 6.0   1st Qu.: 6.0  
##  Median :11.0   Median :10.0   Median : 8.0   Median : 8.0  
##  Mean   :11.8   Mean   :11.7   Mean   :10.3   Mean   :10.2  
##  3rd Qu.:15.0   3rd Qu.:15.0   3rd Qu.:13.0   3rd Qu.:13.0  
##  Max.   :48.0   Max.   :45.0   Max.   :55.0   Max.   :55.0  
##                                                             
##       edad     
##  Min.   : 4.0  
##  1st Qu.: 8.0  
##  Median :11.0  
##  Mean   :11.2  
##  3rd Qu.:14.0  
##  Max.   :33.0  
## 

4.3.3 Cruce de Variables

datos2 = Card2[,c(3:14)]
datos2$Sex = as.numeric(datos2$Sex)
datos2$`IdSchool 1` = as.numeric(datos2$`IdSchool 1`)
datos2$`grade Card 2` = as.numeric(datos2$`grade Card 2`)

#Obtener matriz de correlacion
cormat = round(cor(datos2,use = "complete.obs"),2)
#Reordenar matriz de correlacion
reorder_cormat <- function(cormat){
# Use correlation between variables as distance
dd <- as.dist((1-cormat)/2)
hc <- hclust(dd)
cormat <-cormat[hc$order, hc$order]
}
cormat = reorder_cormat(cormat)
#Obtener triangulo superior
get_upper_tri = function(cormat){
  cormat[lower.tri(cormat)] = NA
  return(cormat)
}
upper_tri = get_upper_tri(cormat)
#Correlacion como heatmap
require(reshape2)
melted_cormat = melt(upper_tri, na.rm = T)
require(ggplot2)
ggheatmap = ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill = value)) + geom_tile(color = "white") + scale_fill_gradient2(low = "blue",high = "red",mid = "white", midpoint = 0, limit = c(-1,1), space = "Lab", name="Correlacion") + theme_minimal() + theme(axis.text.x = element_text(angle = 90, vjust = 1,hjust = 1)) + coord_fixed()

ggheatmap + 
geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
theme(
  axis.title.x = element_blank(),
  axis.title.y = element_blank(),
  panel.grid.major = element_blank(),
  panel.border = element_blank(),
  panel.background = element_blank(),
  axis.ticks = element_blank(),
  legend.justification = c(1, 0),
  legend.position = c(0.6, 0.7),
  legend.direction = "horizontal")+
  guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
                title.position = "top", title.hjust = 0.5))

En la matriz de correlacion podemos ver que cada par de variables que se miden como 1 y 2, se representan una a la otra. Esto nos permite descartarlas para futuros modelos. Por otro lado, el sexo y el colegio son las variables con menos relacion respecto a las otras.

4.3.4 Grafico Exploratorios

4.3.5 Cluster

De primero corramos un diagrama de codo del metodo de Ward para definir la cantidad de grupos a realizar.

cluster = unique(Card2[,c(3,4,5,7,8,10,13,14)])
cluster$Sex = as.numeric(cluster$Sex)
cluster$`IdSchool 1` = as.numeric(cluster$`IdSchool 1`)
cluster$`grade Card 2` = as.numeric(cluster$`grade Card 2`)

set.seed(543)
wss <- (nrow(cluster[,c()])-1)*sum(apply(cluster[,1:ncol(cluster)],2,var))

for (i in 2:10) 
  wss[i] <- sum(kmeans(cluster[,1:ncol(cluster)], centers=i)$withinss)

plot(2:
       10, wss[c(2:10)], type="b", xlab="Number of Cluster",  ylab="Squares Summatory", main = "Diagrama de Codo")

Propongo 3 o 4 como la cantidad de cluster a realizar. Realizaremos el modelo de k-medias con k = 4 de primero, ya que existe la sospecha de que k = 3 sera la cantidad correcta.

set.seed(91)

km<-kmeans(cluster,4)
cluster$grupo<-km$cluster

plotcluster(cluster[,c(1:8)],km$cluster) 

km<-kmeans(cluster,3)
cluster$grupo<-km$cluster

plotcluster(cluster[,c(1:8)],km$cluster)

Se sospechaba lo correcto, creando 4 clusters pareciera que estamos creando una pequeña particion en un de los grupos. Pero haciendo 3 clusters, los grupos se diferencian muy bien entre si. Ahosra que ya tenemos los distintos grupos, visualicemoslos e identifiquemos patrones dentro de ellos.

ggplot(data = cluster, aes(group = grupo, y = edad, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Edad") + ylim(c(0,25))

## Warning: Removed 5 rows containing non-finite values (stat_boxplot).

ggplot(data = cluster, aes(group = grupo, y = `UAC1 cm`, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("UAC1 (cm)") + ylim(c(0,35))

## Warning: Removed 73 rows containing non-finite values (stat_boxplot).

ggplot(data = cluster, aes(group = grupo, y = `TST1 mm`, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("TST1 (mm)") + ylim(c(0,35))

## Warning: Removed 110 rows containing non-finite values (stat_boxplot).

ggplot(data = cluster, aes(group = grupo, y = `SSF2 mm`, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("SSF2 (mm)") + ylim(c(0,40))

## Warning: Removed 81 rows containing non-finite values (stat_boxplot).

ggplot(data = cluster, aes(group = grupo, y = `grade Card 2`, fill = grupo)) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Grado Escolar")

Podemos ver que el grupo mas diferente es el Grupo 2, mientras que el Grupo 1 y el 3 son muy parecidos. La distribucion de SSF2, UAC1 y TST1 son muy similares pero lo que marca la diferencia entre ellos es la edad y el grade Card 2. Donde el Grupo 1 es un grupo con edades mayores que las del grupo 3. En orden descendiente ordeno los grupos de la siguiente manera.

1. Grupo 2
2. Grupo 1
3. Grupo 3

5 Conclusiones